home *** CD-ROM | disk | FTP | other *** search
/ 8bitfiles.net/archives / archives.tar / archives / compuserve-file-archive / 05 Programming / LISP2.TXT < prev    next >
Text File  |  2019-04-13  |  15KB  |  477 lines
  1. PROGRAM LISP;
  2. LABEL 101, 102;
  3. CONST MAXNODE = 1000;
  4. TYPE
  5.   INPUTSYMBOL = (ATOM, PERIOD, LPAREN, RPAREN);
  6.   RWORDS = (RHSYM, RTSYM, HEADSYM, TAILSYM, EQSYM, QUOTESYM,
  7.      ATOMSYM, CONDSYM, LABELSYM, LAMBDASYM, COPYSYM, APPENDSYM, CONCSYM,
  8.      CONSSYM);
  9. STATUSTYPE = (UNMARKED, LEFT, RIGHT, MARKED);
  10. SYMBEXPPTR = ^SYMBOLICEXPRESSION;
  11. ALFA = PACKED ARRAY [1 .. 10] OF CHAR;
  12. SYMBOLICEXPRESSION = RECORD
  13.       STATUS : STATUSTYPE;
  14.       NEXT   : SYMBEXPPTR;
  15.  CASE ANATOM : BOOLEAN OF
  16.       TRUE   : (NAME : ALFA;
  17.                CASE ISARESERVEDWORD : BOOLEAN OF
  18.                     TRUE : (RESSYM : RWORDS));
  19.       FALSE  : (HEAD, TAIL : SYMBEXPPTR)
  20.  END;
  21. VAR
  22.   LOOKAHEADSYM, SYM : INPUTSYMBOL ;
  23.   ID : ALFA;
  24.   ALREADYPEEKED : BOOLEAN ;
  25.   CH : CHAR ;
  26.   PTR : SYMBEXPPTR;
  27.   FREELIST, NODELIST, ALIST : SYMBEXPPTR;
  28.   NILNODE, TNODE : SYMBOLICEXPRESSION;
  29.   RESWORD : RWORDS;
  30.   RESERVED : BOOLEAN ;
  31.   RESWORDS : ARRAY [RWORDS] OF ALFA;
  32.   FREENODES : INTEGER;
  33.   NUMBEROFGCS : INTEGER;
  34. PROCEDURE GARBAGEMAN;
  35.   PROCEDURE MARK(VAR LIST : SYMBEXPPTR);
  36.   VAR FATHER, SON, CURRENT : SYMBEXPPTR;
  37.   BEGIN
  38.     FATHER := NIL; CURRENT := LIST; SON := CURRENT;
  39.     WHILE CURRENT <> NIL DO
  40.       WITH CURRENT^ DO
  41.         CASE STATUS OF
  42.           UNMARKED:
  43.             IF ANATOM THEN STATUS := MARKED
  44.             ELSE IF (HEAD^.STATUS <> UNMARKED) OR (HEAD = CURRENT)
  45.                  THEN
  46.                    IF (TAIL^.STATUS <> UNMARKED) OR (TAIL = CURRENT)
  47.                    THEN STATUS := MARKED
  48.                    ELSE
  49.                      BEGIN
  50.                        STATUS := RIGHT; SON := TAIL; TAIL := FATHER;
  51.                        FATHER := CURRENT; CURRENT := SON
  52.                      END
  53.                  ELSE
  54.                    BEGIN
  55.                      STATUS := LEFT; SON := HEAD; HEAD := FATHER;
  56.                      FATHER := CURRENT; CURRENT := SON
  57.                    END;
  58.           LEFT :
  59.             IF TAIL^.STATUS <> UNMARKED THEN
  60.               BEGIN
  61.                 STATUS := MARKED; FATHER := HEAD; HEAD := SON;
  62.                 SON := CURRENT
  63.               END
  64.             ELSE
  65.               BEGIN
  66.                 STATUS := RIGHT; CURRENT := TAIL; TAIL := HEAD;
  67.                 HEAD := SON; SON := CURRENT
  68.               END;
  69.           RIGHT:
  70.             BEGIN
  71.               STATUS := MARKED; FATHER := TAIL; TAIL := SON;
  72.               SON := CURRENT
  73.             END;
  74.           MARKED : CURRENT := FATHER
  75.         END
  76.     END;
  77.   PROCEDURE COLLECTFREENODES;
  78.     VAR TEMP : SYMBEXPPTR;
  79.     BEGIN
  80.       WRITE(' NUMBER OF NODES BEFORE COLLECTION = ', FREENODES:1, '.');
  81.     FREELIST := NIL; FREENODES := 0; TEMP := NODELIST;
  82.     WHILE TEMP <> NIL DO
  83.       BEGIN
  84.         IF TEMP^.STATUS <> UNMARKED THEN TEMP^.STATUS := UNMARKED
  85.         ELSE
  86.           BEGIN
  87.             FREENODES := FREENODES + 1; TEMP^.HEAD := FREELIST;
  88.             FREELIST := TEMP
  89.           END;
  90.         TEMP := TEMP^.NEXT
  91.       END;
  92.     WRITELN(' NUMBER OF FREENODES AFTER COLLECTION = ',FREENODES:1,'.')
  93.   END;
  94. BEGIN
  95.   NUMBEROFGCS := NUMBEROFGCS + 1; WRITELN;
  96.   WRITELN('GARBAGE COLLECTION.'); WRITELN; MARK(ALIST);
  97.   IF PTR <> NIL THEN MARK(PTR); COLLECTFREENODES
  98. END;
  99. PROCEDURE POP(VAR SPTR : SYMBEXPPTR);
  100.   BEGIN
  101.     IF FREELIST = NIL THEN
  102.       BEGIN
  103.         WRITELN('NOT ENOUGH SPACE TO EVALUATE THE EXPRESSION');
  104.         GOTO 102
  105.       END;
  106.     FREENODES := FREENODES - 1; SPTR := FREELIST;
  107.     FREELIST := FREELIST^.HEAD
  108.   END;
  109. PROCEDURE ERROR(NUMBERS : INTEGER);
  110.   BEGIN
  111.     WRITELN; WRITE('eRROR ',NUMBERS:1,',');
  112.     CASE NUMBERS OF
  113.       1 : WRITELN(' ATOM OR ( EXPECTED IN THE S-EXPR.');
  114.       2 : WRITELN(' ATOM, (, OR ) EXPECTED IN THE S-EXPR.');
  115.       3 : WRITELN(' LABEL AND LAMBDA ARE NOT NAMES OF FUNCTIONS.');
  116.       4 : WRITELN(') EXPECTED IN THE S-EXPR.');
  117.       5 : WRITELN('1ST ARGUMENT OF REPLACEH IS AN ATOM.');
  118.       6 : WRITELN('1ST ARGUMENT OF REPLACET IS AN ATOM.');
  119.       7 : WRITELN('ARGUMENT OF HEAD IS AN ATOM.');
  120.       8 : WRITELN('ARGUMENT OF TAIL IS AN ATOM.');
  121.       9 : WRITELN('1ST ARGUMENT OF APPEND IS NOT A LIST.');
  122.       10 : WRITELN(' , OR ) EXPECTED IN CONCATENATE.');
  123.       11 : WRITELN('END OF FILE ENCOUNTERED BEFORE A "FIN" CARD.');
  124.       12 : WRITELN('LAMBDA OR LABEL EXPECTED.')
  125.     END;
  126.     IF NUMBERS IN [11] THEN GOTO 102 ELSE GOTO 101
  127.   END;
  128. PROCEDURE BACKINPUT;
  129.   BEGIN
  130.     ALREADYPEEKED := TRUE; LOOKAHEAD := SYM; SYM := LPAREN
  131.   END;
  132. PROCEDURE NEXTSYM;
  133.   VAR I : INTEGER;
  134.   BEGIN
  135.     IF ALREADYPEEKED
  136.     THEN BEGIN SYM := LOOKAHEADSYM; ALREADYPEEKED := FALSE END
  137.     ELSE
  138.       BEGIN
  139.         WHILE CH = ' ' DO
  140.           BEGIN IF EOLN THEN WRITELN; READ(CH);
  141.           END;
  142.         IF CH IN ['(','.',')']
  143.         THEN
  144.           BEGIN
  145.             CASE CH OF
  146.               '(': SYM := LPAREN;
  147.               '.': SYM := PERIOD;
  148.               ')': SYM := RPAREN;
  149.             END;
  150.             IF EOLN THEN WRITELN; READ(CH);
  151.           END
  152.         ELSE
  153.           BEGIN
  154.             SYM := ATOM; ID := '          '; I := 0;
  155.             REPEAT
  156.               I := I + 1; IF I<11 THEN ID[I] := CH;
  157.               IF EOLN THEN WRITELN; READ(CH)
  158.             UNTIL CH IN [' ','(','.',')'];
  159.             RESWORD := RHSYM;
  160.             WHILE (ID <> RESWORDS[RESWORD]) AND (RESWORD <> CONSSYM) DO
  161.               RESWORD := SUCC(RESWORD);
  162.             RESERVED := ID = RESWORDS[RESWORD]
  163.           END
  164.       END
  165.   END;
  166. PROCEDURE READEXPR(VAR SPTR : SYMBEXPPTR);
  167.   VAR NXT : SYMBEXPPTR;
  168.   BEGIN
  169.     POP(SPTR); NXT := SPTR^.NEXT;
  170.     CASE SYM OF
  171.       RPAREN, PERIOD : ERROR(1);
  172.       ATOM:
  173.         WITH SPTR^ DO
  174.           BEGIN
  175.             ANATOM := TRUE; NAME := ID; ISARESERVEDWORD := RESERVED;
  176.             IF RESERVED THEN RESSYM := RESWORD
  177.           END;
  178.       LPAREN:
  179.         WITH SPTR^ DO
  180.           BEGIN
  181.             NEXTSYM;
  182.             IF SYM = PERIOD THEN ERROR(2)
  183.             ELSE
  184.               IF SYM = RPAREN THEN SPTR^ := NILNODE
  185.               ELSE
  186.                 BEGIN
  187.                   ANATOM := FALSE; READEXPR(HEAD); NEXTSYM;
  188.                   IF SYM = PERIOD
  189.                   THEN
  190.                     BEGIN
  191.                       NEXTSYM; READEXPR(TAIL); NEXTSYM;
  192.                       IF SYM <> RPAREN THEN ERROR(4)
  193.                     END
  194.                   ELSE
  195.                     BEGIN
  196.                       BACKINPUT; READEXPR(TAIL)
  197.                     END
  198.                 END
  199.           END
  200.     END;
  201.     SPTR^.NEXT := NXT
  202.   END;
  203. PROCEDURE PRINTNAME(VAR NAME : ALFA);
  204.   VAR I : INTEGER;
  205.   BEGIN
  206.     I := 1;
  207.     REPEAT
  208.       WRITE(NAME[I]);
  209.       I := I + 1;
  210.     UNTIL (NAME[I] = ' ') OR (I = 11);
  211.     WRITE(' ')
  212.   END;
  213. PROCEDURE PRINTEXPR(SPTR : SYMBEXPPTR);
  214.   LABEL 103;
  215.   BEGIN
  216.     IF SPTR^.ANATOM THEN PRINTNAME(SPTR^.NAME)
  217.     ELSE
  218.       BEGIN
  219.         WRITE('(');
  220.      103: WITH SPTR^ DO
  221.           BEGIN
  222.             PRINTEXPR(HEAD);
  223.             IF TAIL^.ANATOM AND (TAIL^.NAME = 'NIL       ')
  224.             THEN WRITE(')')
  225.             ELSE
  226.               IF TAIL^.ANATOM
  227.               THEN
  228.                 BEGIN WRITE('.');PRINTEXPR(TAIL); WRITE(')')  END
  229.               ELSE BEGIN SPTR := TAIL; GOTO 103 END
  230.           END
  231.       END
  232. END;
  233. FUNCTION EVAL(E, ALIST : SYMBEXPPTR) : SYMBEXPPTR;
  234.   VAR TEMP, CAROFE, CAAROFE : SYMBEXPPTR;
  235.   FUNCTION REPLACEH(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
  236.     BEGIN
  237.       IF SPTR1^.ANATOM THEN ERROR(5) ELSE SPTR1^.HEAD := SPTR2;
  238.       REPLACEH := SPTR1
  239.     END;
  240.   FUNCTION REPLACET(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
  241.     BEGIN
  242.       IF SPTR1^.ANATOM THEN ERROR(6) ELSE SPTR1^.TAIL := SPTR2;
  243.       REPLACET := SPTR1
  244.     END;
  245.   FUNCTION HEAD(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
  246.     BEGIN
  247.       IF SPTR^.ANATOM THEN ERROR(7) ELSE HEAD := SPTR^.HEAD
  248.     END;
  249.   FUNCTION TAIL(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
  250.     BEGIN
  251.       IF SPTR^.ANATOM THEN ERROR(8) ELSE TAIL := SPTR^.TAIL
  252.     END;
  253.   FUNCTION CONS(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
  254.     VAR TEMP : SYMBEXPPTR;
  255.     BEGIN
  256.       POP(TEMP); TEMP^.ANATOM := FALSE; TEMP^.HEAD := SPTR1;
  257.       TEMP^.TAIL := SPTR2; CONS := TEMP;
  258.     END;
  259.   FUNCTION COPY(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
  260.     VAR TEMP, NXT : SYMBEXPPTR;
  261.     BEGIN
  262.       IF SPTR^.ANATOM
  263.       THEN
  264.         BEGIN
  265.           POP(TEMP); NXT := TEMP^.NEXT; TEMP := SPTR;
  266.           TEMP^.NEXT := NXT; COPY := TEMP
  267.         END
  268.       ELSE COPY := CONS(COPY(SPTR^.HEAD),COPY(SPTR^.TAIL))
  269.     END;
  270.   FUNCTION APPEND(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
  271.     BEGIN
  272.       IF SPTR1^.ANATOM
  273.       THEN
  274.         IF SPTR1^.NAME <> 'NIL       ' THEN ERROR(9)
  275.         ELSE APPEND := SPTR2
  276.       ELSE
  277.         APPEND := CONS(COPY(SPTR1^.HEAD),APPEND(SPTR1^.TAIL,SPTR2))
  278.     END;
  279.   FUNCTION CONC(SPTR1 : SYMBEXPPTR) : SYMBEXPPTR;
  280.     VAR SPTR2, NILPTR : SYMBEXPPTR;
  281.     BEGIN
  282.       IF SYM <> RPAREN
  283.       THEN
  284.         BEGIN
  285.           NEXTSYM; READEXPR(SPTR2); NEXTSYM;
  286.           CONC := CONS(SPTR1,CONC(SPTR2));
  287.         END
  288.       ELSE
  289.         IF SYM = RPAREN
  290.         THEN
  291.           BEGIN
  292.             NEW(NILPTR);
  293.             WITH NILPTR^ DO
  294.               BEGIN ANATOM := TRUE; NAME := 'NIL       ' END;
  295.             CONC := CONS(SPTR1, NILPTR)
  296.           END
  297.         ELSE ERROR(10)
  298.     END;
  299.   FUNCTION EQQ(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
  300.     VAR TEMP, NXT : SYMBEXPPTR;
  301.     BEGIN
  302.       POP(TEMP); NXT := TEMP^.NEXT;
  303.       IF SPTR1^.ANATOM AND SPTR2^.ANATOM
  304.       THEN
  305.         IF SPTR1^.NAME = SPTR2^.NAME THEN TEMP^ := TNODE
  306.         ELSE TEMP^ := NILNODE
  307.       ELSE
  308.         IF SPTR1 = SPTR2 THEN TEMP^ := TNODE
  309.         ELSE TEMP^ := NILNODE;
  310.       TEMP^.NEXT := NXT; EQQ := TEMP
  311.     END;
  312.   FUNCTION ATOM(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
  313.     VAR TEMP, NXT : SYMBEXPPTR;
  314.     BEGIN
  315.       POP(TEMP); NXT := TEMP^.NEXT;
  316.       IF SPTR^.ANATOM THEN TEMP^ := TNODE ELSE TEMP^ := NILNODE;
  317.       TEMP^.NEXT := NXT; ATOM := TEMP
  318.     END;
  319.   FUNCTION LOOKUP(KEY, ALIST : SYMBEXPPTR) : SYMBEXPPTR;
  320.     VAR TEMP : SYMBEXPPTR;
  321.     BEGIN
  322.       TEMP := EQQ(HEAD(HEAD(ALIST)),KEY);
  323.       IF TEMP^.NAME = 'T         ' THEN LOOKUP := TAIL(HEAD(ALIST))
  324.       ELSE LOOKUP := LOOKUP(KEY,TAIL(ALIST))
  325.     END;
  326.   FUNCTION BINDARGS(NAMES, VALUES : SYMBEXPPTR) : SYMBEXPPTR;
  327.     VAR TEMP, TEMP2 : SYMBEXPPTR;
  328.     BEGIN
  329.       IF NAMES^.ANATOM AND (NAMES^.NAME = 'NIL       ')
  330.       THEN BINDARGS := ALIST
  331.       ELSE
  332.         BEGIN
  333.           TEMP := CONS(HEAD(NAMES),EVAL(HEAD(VALUES),ALIST));
  334.           TEMP2 := BINDARGS(TAIL(NAMES),TAIL(VALUES));
  335.           BINDARGS := CONS(TEMP,TEMP2)
  336.         END
  337.     END;
  338.   FUNCTION EVCON(CONDPAIRS : SYMBEXPPTR) : SYMBEXPPTR;
  339.     VAR TEMP : SYMBEXPPTR;
  340.     BEGIN
  341.       TEMP := EVAL(HEAD(HEAD(CONDPAIRS)),ALIST);
  342.       IF TEMP^.ANATOM AND (TEMP^.NAME = 'NIL       ')
  343.       THEN EVCON := EVCON(TAIL(CONDPAIRS))
  344.       ELSE EVCON := EVAL(HEAD(TAIL(HEAD(CONDPAIRS))),ALIST)
  345.     END;
  346.   BEGIN
  347.     IF E^.ANATOM THEN EVAL := LOOKUP(E,ALIST)
  348.     ELSE
  349.       BEGIN
  350.         CAROFE := HEAD(E);
  351.         IF CAROFE^.ANATOM
  352.         THEN
  353.           IF NOT CAROFE^.ISARESERVEDWORD
  354.           THEN
  355.             EVAL := EVAL(CONS(LOOKUP(CAROFE,ALIST),TAIL(E)),ALIST)
  356.           ELSE
  357.             CASE CAROFE^.RESSYM OF
  358.               LABELSYM, LAMBDASYM : ERROR(3);
  359.               QUOTESYM : EVAL := HEAD(TAIL(E));
  360.               ATOMSYM : EVAL := ATOM(EVAL(HEAD(TAIL(E)),ALIST));
  361.               EQSYM : EVAL := EQQ(EVAL(HEAD(TAIL(E)),ALIST),EVAL(HEAD(
  362.                    TAIL(TAIL(E))),ALIST));
  363.               HEADSYM : EVAL := HEAD(EVAL(HEAD(TAIL(E)),ALIST));
  364.               TAILSYM : EVAL := TAIL(EVAL(HEAD(TAIL(E)),ALIST));
  365.               CONSSYM : EVAL := CONS(EVAL(HEAD(TAIL(E)),ALIST),
  366.                EVAL(HEAD(TAIL(TAIL(E))),ALIST));
  367.               CONDSYM : EVAL := EVCON(TAIL(E));
  368.         APPENDSYM : EVAL := APPEND(EVAL(HEAD(TAIL(E)),ALIST),EVAL(HEAD(
  369.                TAIL(TAIL(E))),ALIST))
  370.             END
  371.         ELSE
  372.           BEGIN
  373.             CAAROFE := HEAD(CAROFE);
  374.             IF CAAROFE^.ANATOM AND CAAROFE^.ISARESERVEDWORD
  375.             THEN
  376.               IF NOT (CAAROFE^.RESSYM IN [LABELSYM, LAMBDASYM])
  377.               THEN ERROR(12)
  378.               ELSE
  379.                 CASE CAAROFE^.RESSYM OF
  380.                   LABELSYM:
  381.                     BEGIN
  382.                       TEMP := CONS(CONS(HEAD(TAIL(CAROFE)),HEAD(TAIL(
  383.                           TAIL(CAROFE)))),ALIST);
  384.                       EVAL := EVAL(CONS(HEAD(TAIL(TAIL(CAROFE))),
  385.                            TAIL(E)),TEMP)
  386.                     END;
  387.                   LAMBDASYM:
  388.                     BEGIN
  389.                       TEMP := BINDARGS(HEAD(TAIL(CAROFE)),TAIL(E));
  390.                       EVAL := EVAL(HEAD(TAIL(TAIL(CAROFE))),TEMP)
  391.                     END;
  392.                 END
  393.               ELSE
  394.                 EVAL := EVAL(CONS(EVAL(CAROFE,ALIST),TAIL(E)),ALIST)
  395.             END
  396.           END
  397.   END;
  398. PROCEDURE INITIALIZE;
  399.   VAR I : INTEGER;
  400.   TEMP, NXT : SYMBEXPPTR;
  401.   BEGIN
  402.     ALREADYPEEKED := FALSE; READ(CH); NUMBEROFGCS := 0;
  403.     FREENODES := MAXNODE;
  404.     WITH NILNODE DO
  405.       BEGIN
  406.         ANATOM := TRUE; NEXT := NIL; NAME := 'NIL       ';
  407.         STATUS := UNMARKED; ISARESERVEDWORD := FALSE
  408.       END;
  409.     WITH TNODE DO
  410.       BEGIN
  411.         ANATOM := TRUE; NEXT := NIL; NAME := 'T         ';
  412.         STATUS := UNMARKED; ISARESERVEDWORD := FALSE
  413.       END;
  414.     FREELIST := NIL;
  415.     FOR I := 1 TO MAXNODE DO
  416.       BEGIN
  417.         NEW(NODELIST); NODELIST^.NEXT := FREELIST;
  418.         NODELIST^.HEAD := FREELIST; NODELIST^.STATUS := UNMARKED;
  419.         FREELIST := NODELIST
  420.       END;
  421.     RESWORDS[RHSYM]     := 'REPLACEH  ';
  422.     RESWORDS[RTSYM]     := 'REPLACET  ';
  423.     RESWORDS[HEADSYM]   := 'CAR       ';
  424.     RESWORDS[TAILSYM]   := 'CDR       ';
  425.     RESWORDS[COPYSYM]   := 'COPY      ';
  426.     RESWORDS[APPENDSYM] := 'APPEND    ';
  427.     RESWORDS[CONCSYM]   := 'CONC      ';
  428.     RESWORDS[CONSSYM]   := 'CONS      ';
  429.     RESWORDS[EQSYM]     := 'EQ        ';
  430.     RESWORDS[QUOTESYM]  := 'QUOTESYM  ';
  431.     RESWORDS[ATOMSYM]   := 'ATOM      ';
  432.     RESWORDS[CONDSYM]   := 'COND      ';
  433.     RESWORDS[LABELSYM]  := 'LABEL     ';
  434.     RESWORDS[LAMBDASYM] := 'LAMBDA    ';
  435.     POP(ALIST); ALIST^.ANATOM := FALSE; ALIST^.STATUS := UNMARKED;
  436.     POP(ALIST^.TAIL); NXT := ALIST^.TAIL^.NEXT;
  437.     POP(ALIST^.HEAD);
  438.     WITH ALIST^.HEAD^ DO
  439.       BEGIN
  440.         ANATOM := FALSE; STATUS := UNMARKED; POP(HEAD);
  441.         NXT := HEAD^.NEXT; HEAD^ := NILNODE; HEAD^.NEXT := NXT;
  442.         POP(TAIL); NXT := TAIL^.NEXT; TAIL^ := NILNODE;
  443.         TAIL^.NEXT := NXT
  444.       END;
  445.     POP(TEMP); TEMP^.ANATOM := FALSE; TEMP^.STATUS := UNMARKED;
  446.     TEMP^.TAIL := ALIST; ALIST := TEMP;
  447.     POP(ALIST^.HEAD);
  448.     WITH ALIST^.HEAD^ DO
  449.       BEGIN
  450.         ANATOM := FALSE; STATUS := UNMARKED; POP(HEAD);
  451.         NXT := HEAD^.NEXT; HEAD^ := TNODE; HEAD^.NEXT := NXT;
  452.         POP(TAIL); NXT := TAIL^.NEXT; TAIL^ := TNODE;
  453.         TAIL^.NEXT := NXT
  454.       END;
  455.   END;
  456. BEGIN
  457. IOTRAP(FALSE);
  458.   WRITELN(' * EVAL * '); INITIALIZE; NEXTSYM; READEXPR(PTR);
  459.   READLN; WRITELN;
  460.   WHILE NOT PTR^.ANATOM OR (PTR^.NAME <> 'FIN       ') DO
  461.     BEGIN
  462.       WRITELN; WRITELN(' * VALUE * ');
  463.       PRINTEXPR(EVAL(PTR, ALIST));
  464.  101: WRITELN; WRITELN; IF EOF THEN ERROR(11);
  465.       PTR := NIL;
  466.       GARBAGEMAN; WRITELN; WRITELN;
  467.       WRITELN('EVAL'); NEXTSYM; READEXPR(PTR); READLN;
  468.       WRITELN
  469.     END;
  470. 102: WRITELN; WRITELN;
  471.      WRITELN('TOTAL NUMBER OF GARBAGE COLLECTIONS = ',NUMBEROFGCS:1,
  472.            '.');
  473.      WRITELN;
  474.      WRITELN('FREENODES LEFT UPON EXIT = ',FREENODES:1,'.');
  475.      WRITELN
  476. END.
  477.